First I want a highly interpolated smoothed data set. Same size bins as usual, but depths by meter, or 1/10 meter. I want the change in flux to be like < 1%.
Then I get adjusted DF for every depth. Then I run remin_shuffle on each depth and extract Cr.
Start with bes. I am assuming I have the usual data. I also have SameGam from GenerateFigures.Rmd, which I think is ready to go.
fine_depths <- seq(from = 1, to = 1500, by = 5)
lbbs_FD <- tibble(lb = lb_vec, binsize = binsize_vec)
Expanded_FD <- expand_grid(time = as.factor(unique(besE$time)), lb = lb_vec, depth = BianchiBins[2:length(BianchiBins)]) %>%
left_join(lbbs_FD, by = "lb")
pt0 <- proc.time()
Pred_FD <- exp(predict(SameGam, Expanded_FD))
pt1 <- proc.time()
pt1 - pt0
user system elapsed
6.093 0.020 6.111
Thing_FD <- bind_cols(Expanded_FD, nnparticles = Pred_FD) %>% mutate(time = as.character(time)) %>% mutate(nparticles = nnparticles * binsize)
Too slow Hey. Here’s an idea. Instead of slicing everything super thin, I could just calculate at the BES locations and like 1m below those locations. And then I look at jumps between each depth and the depth below
space <- 0.01
Expanded_FD_Above <- Expanded_FD %>%
mutate(depth = depth - space)
Pred_FD_Above <- exp(predict(SameGam, Expanded_FD_Above))
Thing_FD_Above <- bind_cols(Expanded_FD_Above, nnparticles = Pred_FD_Above) %>% mutate(time = as.character(time)) %>% mutate(nparticles = nnparticles * binsize)
Thing_FD_2 <- bind_cols(Thing_FD, depth_above = Thing_FD_Above$depth, nnparticles_above = Thing_FD_Above$nnparticles, nparticles_above = Thing_FD_Above$nparticles) %>%
mutate(flux = nparticles * C_f_global * lb ^ ag_global,
flux_above = nparticles_above * C_f_global * lb ^ ag_global)
Thing_FD_Nested <- Thing_FD_2 %>% group_by(time, depth) %>%
nest() %>%
mutate(spec_only = map(data, ~pull(., nparticles)),
spec_prev = map(data, ~pull(., nparticles_above))
)
DF = smooth_flux_fit - flux_prev,
#DFP = 1 - DF/flux_prev, # I was using this for a while.
DFP = smooth_flux_fit/flux_prev,
depth_prev = lag(depth),
DZ = depth - depth_prev,
Thing_FD_FSum <- Thing_FD_2 %>% group_by(time, depth, depth_above) %>%
summarize(Flux = sum(flux), Flux_Above = sum(flux_above)) %>%
mutate(DF = Flux - Flux_Above,
DFP = Flux/Flux_Above,
DZ = depth - depth_above)
Thing_FD_FSum
Thing_FD_3 <- left_join(Thing_FD_FSum, Thing_FD_Nested, by = c("time", "depth"))
Thing_FD_3
Thing_FD_4 <- Thing_FD_3 %>%
mutate(use_DFP = map2_dbl(spec_prev, DFP, optFun, llb = little_lb))
Thing_FD_4
Thing_FD_4 %>% ungroup() %>% summarize(DFPMin = min(DFP), UseDFPMin = min(use_DFP))
I’ve been misspecifying alpha and gamma in the remin model.
#loc_rs <- function(abun_in, DFpct, DeltaZ){remin_shuffle()}
Thing_FD_5 <- Thing_FD_4 %>%
mutate(Remin = pmap(list(spec_prev, use_DFP, DZ), remin_shuffle)) %>%
mutate(Cr = map_dbl(Remin, ~.$Cr))
Thing_FD_5
ggplot(Thing_FD_5, aes(y = depth, x = pracma::nthroot(Cr, 5), color = as.factor(time))) + geom_point() + scale_y_reverse(limits = c(1500, 0))

ggplot(Thing_FD_5, aes(y = depth, x = pracma::nthroot(DFP, 5), color = as.factor(time))) + geom_point() + scale_y_reverse(limits = c(1500, 0))

LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKRmlyc3QgSSB3YW50IGEgaGlnaGx5IGludGVycG9sYXRlZCBzbW9vdGhlZCBkYXRhIHNldC4KU2FtZSBzaXplIGJpbnMgYXMgdXN1YWwsIGJ1dCBkZXB0aHMgYnkgbWV0ZXIsIG9yIDEvMTAgbWV0ZXIuIEkgd2FudCB0aGUgY2hhbmdlIGluIGZsdXggdG8gYmUgbGlrZSA8IDElLgoKVGhlbiBJIGdldCBhZGp1c3RlZCBERiBmb3IgZXZlcnkgZGVwdGguClRoZW4gSSBydW4gcmVtaW5fc2h1ZmZsZSBvbiBlYWNoIGRlcHRoIGFuZCBleHRyYWN0IENyLgoKClN0YXJ0IHdpdGggYmVzLiBJIGFtIGFzc3VtaW5nIEkgaGF2ZSB0aGUgdXN1YWwgZGF0YS4gSSBhbHNvIGhhdmUgU2FtZUdhbSBmcm9tIEdlbmVyYXRlRmlndXJlcy5SbWQsIHdoaWNoIEkgdGhpbmsgaXMgcmVhZHkgdG8gZ28uCmBgYHtyfQpmaW5lX2RlcHRocyA8LSBzZXEoZnJvbSA9IDEsIHRvID0gMTUwMCwgYnkgPSA1KQoKbGJic19GRCA8LSB0aWJibGUobGIgPSBsYl92ZWMsIGJpbnNpemUgPSBiaW5zaXplX3ZlYykKRXhwYW5kZWRfRkQgPC0gZXhwYW5kX2dyaWQodGltZSA9IGFzLmZhY3Rvcih1bmlxdWUoYmVzRSR0aW1lKSksIGxiID0gbGJfdmVjLCBkZXB0aCA9IEJpYW5jaGlCaW5zWzI6bGVuZ3RoKEJpYW5jaGlCaW5zKV0pICU+JQogIGxlZnRfam9pbihsYmJzX0ZELCBieSA9ICJsYiIpCgpwdDAgPC0gcHJvYy50aW1lKCkKUHJlZF9GRCA8LSBleHAocHJlZGljdChTYW1lR2FtLCBFeHBhbmRlZF9GRCkpCnB0MSA8LSBwcm9jLnRpbWUoKQpwdDEgLSBwdDAKVGhpbmdfRkQgPC0gYmluZF9jb2xzKEV4cGFuZGVkX0ZELCBubnBhcnRpY2xlcyA9IFByZWRfRkQpICU+JSBtdXRhdGUodGltZSA9IGFzLmNoYXJhY3Rlcih0aW1lKSkgJT4lIG11dGF0ZShucGFydGljbGVzID0gbm5wYXJ0aWNsZXMgKiBiaW5zaXplKQpgYGAKVG9vIHNsb3cKSGV5LiBIZXJlJ3MgYW4gaWRlYS4gSW5zdGVhZCBvZiBzbGljaW5nIGV2ZXJ5dGhpbmcgc3VwZXIgdGhpbiwgSSBjb3VsZCBqdXN0IGNhbGN1bGF0ZSBhdCB0aGUgQkVTIGxvY2F0aW9ucyBhbmQgbGlrZSAxbSBiZWxvdyB0aG9zZSBsb2NhdGlvbnMuCkFuZCB0aGVuIEkgbG9vayBhdCBqdW1wcyBiZXR3ZWVuIGVhY2ggZGVwdGggYW5kIHRoZSBkZXB0aCBiZWxvdwoKYGBge3J9CnNwYWNlIDwtIDAuMDEKRXhwYW5kZWRfRkRfQWJvdmUgPC0gRXhwYW5kZWRfRkQgJT4lCiAgbXV0YXRlKGRlcHRoID0gZGVwdGggLSBzcGFjZSkKUHJlZF9GRF9BYm92ZSA8LSBleHAocHJlZGljdChTYW1lR2FtLCBFeHBhbmRlZF9GRF9BYm92ZSkpClRoaW5nX0ZEX0Fib3ZlIDwtIGJpbmRfY29scyhFeHBhbmRlZF9GRF9BYm92ZSwgbm5wYXJ0aWNsZXMgPSBQcmVkX0ZEX0Fib3ZlKSAlPiUgbXV0YXRlKHRpbWUgPSBhcy5jaGFyYWN0ZXIodGltZSkpICU+JSBtdXRhdGUobnBhcnRpY2xlcyA9IG5ucGFydGljbGVzICogYmluc2l6ZSkKYGBgCgpgYGB7cn0KVGhpbmdfRkRfMiA8LSBiaW5kX2NvbHMoVGhpbmdfRkQsIGRlcHRoX2Fib3ZlID0gVGhpbmdfRkRfQWJvdmUkZGVwdGgsIG5ucGFydGljbGVzX2Fib3ZlID0gVGhpbmdfRkRfQWJvdmUkbm5wYXJ0aWNsZXMsIG5wYXJ0aWNsZXNfYWJvdmUgPSBUaGluZ19GRF9BYm92ZSRucGFydGljbGVzKSAlPiUKICBtdXRhdGUoZmx1eCA9IG5wYXJ0aWNsZXMgKiBDX2ZfZ2xvYmFsICogbGIgXiBhZ19nbG9iYWwsCiAgICAgICAgIGZsdXhfYWJvdmUgPSBucGFydGljbGVzX2Fib3ZlICogQ19mX2dsb2JhbCAqIGxiIF4gYWdfZ2xvYmFsKQpgYGAKCmBgYHtyfQpUaGluZ19GRF9OZXN0ZWQgPC0gVGhpbmdfRkRfMiAlPiUgZ3JvdXBfYnkodGltZSwgZGVwdGgpICU+JSAKICBuZXN0KCkgJT4lCiAgbXV0YXRlKHNwZWNfb25seSA9IG1hcChkYXRhLCB+cHVsbCguLCBucGFydGljbGVzKSksCiAgICAgICAgIHNwZWNfcHJldiA9IG1hcChkYXRhLCB+cHVsbCguLCBucGFydGljbGVzX2Fib3ZlKSkKICApCmBgYAoKCiAgICAgICAgICAgREYgPSBzbW9vdGhfZmx1eF9maXQgLSBmbHV4X3ByZXYsCiAgICAgICAgICAgI0RGUCA9IDEgLSBERi9mbHV4X3ByZXYsICAjIEkgd2FzIHVzaW5nIHRoaXMgZm9yIGEgd2hpbGUuCiAgICAgICAgICAgREZQID0gc21vb3RoX2ZsdXhfZml0L2ZsdXhfcHJldiwKICAgICAgICAgICBkZXB0aF9wcmV2ID0gbGFnKGRlcHRoKSwKICAgICAgICAgICBEWiA9IGRlcHRoIC0gZGVwdGhfcHJldiwKCmBgYHtyfQpUaGluZ19GRF9GU3VtIDwtIFRoaW5nX0ZEXzIgJT4lIGdyb3VwX2J5KHRpbWUsIGRlcHRoLCBkZXB0aF9hYm92ZSkgJT4lIAogIHN1bW1hcml6ZShGbHV4ID0gc3VtKGZsdXgpLCBGbHV4X0Fib3ZlID0gc3VtKGZsdXhfYWJvdmUpKSAlPiUKICBtdXRhdGUoREYgPSBGbHV4IC0gRmx1eF9BYm92ZSwKICAgICAgICAgREZQID0gRmx1eC9GbHV4X0Fib3ZlLAogICAgICAgICBEWiA9IGRlcHRoIC0gZGVwdGhfYWJvdmUpCgpUaGluZ19GRF9GU3VtCmBgYAoKYGBge3J9ClRoaW5nX0ZEXzMgPC0gbGVmdF9qb2luKFRoaW5nX0ZEX0ZTdW0sIFRoaW5nX0ZEX05lc3RlZCwgYnkgPSBjKCJ0aW1lIiwgImRlcHRoIikpClRoaW5nX0ZEXzMKYGBgCgpgYGB7cn0KVGhpbmdfRkRfNCA8LSBUaGluZ19GRF8zICU+JQogIG11dGF0ZSh1c2VfREZQID0gbWFwMl9kYmwoc3BlY19wcmV2LCBERlAsIG9wdEZ1biwgbGxiID0gbGl0dGxlX2xiKSkKVGhpbmdfRkRfNApgYGAKCmBgYHtyfQpUaGluZ19GRF80ICU+JSB1bmdyb3VwKCkgJT4lIHN1bW1hcml6ZShERlBNaW4gPSBtaW4oREZQKSwgVXNlREZQTWluID0gbWluKHVzZV9ERlApKQpgYGAKCkkndmUgYmVlbiBtaXNzcGVjaWZ5aW5nIGFscGhhIGFuZCBnYW1tYSBpbiB0aGUgcmVtaW4gbW9kZWwuCmBgYHtyfQojbG9jX3JzIDwtIGZ1bmN0aW9uKGFidW5faW4sIERGcGN0LCBEZWx0YVope3JlbWluX3NodWZmbGUoKX0KVGhpbmdfRkRfNSA8LSBUaGluZ19GRF80ICU+JQogIG11dGF0ZShSZW1pbiA9IHBtYXAobGlzdChzcGVjX3ByZXYsIHVzZV9ERlAsIERaKSwgcmVtaW5fc2h1ZmZsZSkpICU+JQogIG11dGF0ZShDciA9IG1hcF9kYmwoUmVtaW4sIH4uJENyKSkKVGhpbmdfRkRfNQpgYGAKCmBgYHtyfQpnZ3Bsb3QoVGhpbmdfRkRfNSwgYWVzKHkgPSBkZXB0aCwgeCA9IHByYWNtYTo6bnRocm9vdChDciwgNSksIGNvbG9yID0gYXMuZmFjdG9yKHRpbWUpKSkgKyBnZW9tX3BvaW50KCkgKyBzY2FsZV95X3JldmVyc2UobGltaXRzID0gYygxNTAwLCAwKSkKYGBgCgpgYGB7cn0KZ2dwbG90KFRoaW5nX0ZEXzUsIGFlcyh5ID0gZGVwdGgsIHggPSBwcmFjbWE6Om50aHJvb3QoREZQLCA1KSwgY29sb3IgPSBhcy5mYWN0b3IodGltZSkpKSArIGdlb21fcG9pbnQoKSArIHNjYWxlX3lfcmV2ZXJzZShsaW1pdHMgPSBjKDE1MDAsIDApKQpgYGAK